home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Forever 4
/
Atari Forever 4.zip
/
Atari Forever 4.iso
/
PD_THEMA
/
DENKSPIE
/
SCHIEBER
/
EDITOR3.GFA
(
.txt
)
next >
Wrap
GFA-BASIC Atari
|
1986-02-05
|
17KB
|
797 lines
' #############################################################################
' # æ M O T E L S O F T æ #
' #############################################################################
'
' -----------------------------------------------------------------------------
' Arbeitstitel >feldindex<
' -----------------------------------------------------------------------------
' CO.HARALD BREITMAIER MARKUSPLATZ 3 7000 STUTTGART 1
' TEL. 0711~640 22 87
' #############################################################################
' ----------> DATUM <------------ ---------->VERSION 1.0 <---------
SETTIME "","28.06.88"
' #############################################################################
ON ERROR GOSUB gfa1
ON BREAK CONT
' ON BREAK GOSUB gfa2
SETCOLOR 0,0
SETCOLOR 15,7,7,7
CLS
GOSUB pic1
' -------------------------
'
number%=1 !PASSWORT
fx%=16 !feldgrösse eintragen
fy%=15
xmax%=240 !bildgrösse / BILDSCHIRMBEREICH
ymax%=199 !dato
xx%=xmax% DIV fx%
yy%=ymax% DIV fy%
' -------------------------
farb%=2 !def
' -------------------------
DIM feld%(fx%+2,fy%+2) !PLUS 2 WICHTIG BEI SPÄTEREN FELDABFRAGEN
GOSUB bilo
' -------------------------
GOSUB creat
'
' -------------------------
> PROCEDURE creat
' -------------------------
' -------------------------
x%=0
y%=0
DEFFILL 0,1,8
COLOR 1
' -----
GOSUB rand1
FOR i%=1 TO fy%
FOR ii%=1 TO fx%
q1%=feld%(ii%,i%)
PUT x%,y%,bil$(q1%-1) ! PBOX x%,y%,x%+xx%,y%+yy%
' BOX x%,y%,x%+xx%,y%+yy%
ADD x%,xx%
NEXT ii%
ADD y%,yy%
x%=0
NEXT i%
tuees:
GOSUB maus(xx%,yy%,2,fx%-1,2,fy%-1)
'
GOTO tuees
RETURN
' -------------------------
PROCEDURE maus(sc1%,sc2%,sc3%,sc4%,sc5%,sc6%)
' teiler x, teiler y,bereich <x >x bereich <y >y
'
'
mausin:
PAUSE 1
SHOWM
'
REPEAT
b$=INKEY$
IF b$<>""
GOSUB action
ENDIF
' -----
MOUSE x%,y%,k%
x%=x% DIV sc1%
y%=y% DIV sc2%
INC x%
INC y%
'
' PRINT AT(1,23);x%;" ";y%;" "
'
UNTIL k% OR b$="S"
' -------------------------
IF b$="S"
GOTO mausex
ENDIF
' -------------------------
x1%=x%-1
y1%=y%-1
' -----
IF x%<sc3% OR x%>sc4%
GOTO mausin
ENDIF
IF y%<sc5% OR y%>sc6%
GOTO mausin
ENDIF
' -------------------------
q1%=feld%(x%,y%)
' -----
IF k%=2
feld%(x%,y%)=8 !7
' DEFFILL 0
PUT (x1%*xx%),(y1%*yy%),bil$(7) !(x1%*xx%)+xx%,(y1%*yy%)+yy%
' COLOR 1
' BOX (x1%*xx%),(y1%*yy%),(x1%*xx%)+xx%,(y1%*yy%)+yy%
ENDIF
' -----
IF k%=1
feld%(x%,y%)=farb%
' DEFFILL farb%
PUT (x1%*xx%),(y1%*yy%),bil$(farb%-1) ! ,(x1%*xx%)+xx%,(y1%*yy%)+yy%
' COLOR 1
' BOX (x1%*xx%),(y1%*yy%),(x1%*xx%)+xx%,(y1%*yy%)+yy%
ENDIF
' -------------------------
GOTO mausin
mausex:
' -----
GOSUB al(2," |FELD SPEICHERN",2," JA |NEIN")
' -----
IF sc5%=2
GOTO mausin
ENDIF
' -----
nochmal:
GOSUB fils("A:\*.FLD","","DATEI SPEICHERN",2)
GOSUB extend(sc3$,"FLD") !FILESTRING EXTENDER
IF sc3$="---" !ABBRUCH - UNGÜLTIGER STRING
GOTO mausin
ENDIF
ff%=INSTR(sc3$,"LEVEL")
IF ff%=0
GOTO nochmal
ENDIF
ADD ff%,5
bbb$=MID$(sc3$,ff%,3)
number%=VAL(bbb$)
IF number%=0
number%=1
ENDIF
IF number%>100
number%=100
ENDIF
'
' -------------------------
CLOSE #1
' -----
OPEN "O",#1,sc3$
' -----
WRITE #1,fx%+2 !GROESSE
WRITE #1,fy%+2
WRITE #1,xmax%
WRITE #1,ymax%
' -----
FOR i%=1 TO fx%+2
FOR ii%=1 TO fy%+2
q1%=feld%(i%,ii%)
WRITE #1,q1%
NEXT ii%
NEXT i%
CLOSE #1
'
' ------------------------------------
pass$=""
FOR i%=1 TO 5
pass%=RANDOM(20)+65
pass$=pass$+CHR$(pass%)
NEXT i%
CLOSE #1
' PRINT AT(1,1);pass$
OPEN "R",#1,"A:\SCHIEBER\ZWEI.RAD",5
FIELD #1,5 AS pass$
PUT #1,number%
CLOSE #1
RETURN
' -------------------------
> PROCEDURE laden
' -----
GOSUB fils("A:\*.FLD","","DATEI LADEN",2)
GOSUB extend(sc3$,"FLD") !FILESTRING EXTENDER
' -----
IF sc3$="---"
GOTO ladenex
ENDIF
' -------------------------
CLOSE #1
' -----
OPEN "I",#1,sc3$
' -----
INPUT #1,fx% !GROESSE
INPUT #1,fy%
INPUT #1,xmax%
INPUT #1,ymax%
' -----
ERASE feld%()
DIM feld%(fx%,fy%)
' -----
FOR i%=1 TO fx%
FOR ii%=1 TO fy%
INPUT #1,q1%
feld%(i%,ii%)=q1%
NEXT ii%
NEXT i%
CLOSE #1
' -----
SUB fx%,2
SUB fy%,2
xx%=xmax% DIV fx%
yy%=ymax% DIV fy%
' -----
COLOR 1
' -------------------------
' -------------------------
x%=0
y%=0
' -----
FOR i%=1 TO fy%
FOR ii%=1 TO fx%
' -----
q1%=feld%(ii%,i%)
DEFFILL q1%
PUT x%,y%,bil$(q1%-1) !x%+xx%,y%+yy%
' BOX x%,y%,x%+xx%,y%+yy%
ADD x%,xx%
NEXT ii%
ADD y%,yy%
x%=0
NEXT i%
' -----
ladenex:
RETURN
' -------------------------
> PROCEDURE action
b$=UPPER$(b$)
' ----
IF b$="T"
GOSUB testlauf
GOTO actionex
ENDIF
' -----
IF b$="S"
GOTO store
ENDIF
' -----
IF b$="C"
ALERT 1," |FELD LÖSCHEN",2," JA |NEIN",ni%
IF ni%=1
GOSUB cl
ENDIF
GOTO actionex
ENDIF
' -----
IF b$="G"
GOSUB al(1," |BOX-GRÖSSE :|X >"+STR$(xx%)+" Y >"+STR$(yy%),1,"OKAY")
GOTO actionex
ENDIF
' -----
IF b$="L"
GOSUB al(2," |FELD LADEN",2," JA |NEIN")
IF sc5%=2
GOTO actionex
ENDIF
GOSUB laden
GOTO actionex
ENDIF
' -----
IF b$="E"
GOSUB elite
GOTO actionex
ENDIF
' -----
zz%=VAL(b$)
IF zz%=0
ALERT 1," |Q U I T T",2," JA |NEIN",sc5%
IF sc5%=1
STICK 0
'
CHDIR "\"
CHAIN "A:\SCHIEBER\SCHIEBER.GFA"
ENDIF
GOTO actionex
ENDIF
' -----
INC zz%
' -----
IF zz%>8
GOTO actionex
ENDIF
' -----
farb%=zz%
' -------------------------
actionex:
b$=""
' -----
store:
RETURN
' -------------------------
> PROCEDURE cl
GOSUB rand1
x%=0
y%=0
DEFFILL 0,1,8
COLOR 1
' -----
FOR i%=1 TO fy%
FOR ii%=1 TO fx%
q1%=feld%(ii%,i%)
PUT x%,y%,bil$(q1%-1) ! PBOX x%,y%,x%+xx%,y%+yy%
' BOX x%,y%,x%+xx%,y%+yy%
ADD x%,xx%
NEXT ii%
ADD y%,yy%
x%=0
NEXT i%
' -----
' -----
RETURN
> PROCEDURE rand1
ARRAYFILL feld%(),8
FOR i%=1 TO fx%
feld%(i%,1)=2
feld%(i%,fy%)=2
NEXT i%
FOR i%=1 TO fy%
feld%(1,i%)=2
feld%(fx%,i%)=2
NEXT i%
RETURN
' -------------------------
> PROCEDURE al(sc1%,sc1$,sc2%,sc2$)
ALERT sc1%,sc1$,sc2%,sc2$,sc5%
RETURN
' -------------------------
> PROCEDURE elite
' -------------------------
RESTORE datf1
FOR i%=1 TO 34
READ farbe%
fab$=fab$+CHR$(farbe%)
NEXT i%
' -------------------------
'
'
ALERT 1,"screen abspeichern",1," Ja | Nein ",ok%
IF ok%=2
GOTO eliteraus
ENDIF
'
GOSUB fils("A:\*.PI1","","BILD SPEICHERN",3)
GOSUB extend(sc3$,"PI1") !FILESTRING EXTENDER
IF sc3$="---" !ABBRUCH - UNGÜLTIGER STRING
GOTO eliteraus
ENDIF
HIDEM !maus weg
GOSUB bisa !bildschirm abspeichern
'
eliteraus:
'
RETURN
'
> PROCEDURE bisa !procedur speichert den bildschirm ab
'
bisa:
CLOSE #1
OPEN "o",#1,sc3$
BPUT #1,VARPTR(fab$),34
BPUT #1,XBIOS(3),32032
CLOSE #1
'
RETURN
' -------------------------
> PROCEDURE extend(aa$,ex$)
' -----
sc1$=""
sc2$=""
' -----
IF aa$=""
sc3$="---"
GOTO exex
ENDIF
' -----
ff%=LEN(aa$)
fff%=0
FOR i%=ff% DOWNTO 1
sc2$=MID$(aa$,i%,1)
IF sc2$="\"
fff%=i%
ENDIF
EXIT IF fff%
NEXT i%
' -----
IF fff%=ff%
sc3$="---"
GOTO exex
ENDIF
' -----
sc2$=LEFT$(aa$,fff%)
sc1$=RIGHT$(aa$,ff%-fff%)
' -----
ff%=INSTR(sc1$,".")
IF ff%=0
sc1$=sc1$+"."+ex$
ENDIF
' -----
IF ff%<>0
IF MID$(sc1$,ff%+1,3)<>ex$
MID$(sc1$,ff%+1,3)=ex$
ENDIF
ENDIF
' -----
sc3$=sc2$+sc1$
' -----
exex:
RETURN
' -------------------------
> PROCEDURE fils(sc1$,sc2$,sc4$,sc1%)
' PFAD,DATEI,WAS>LADEN/SPEICHERN,TEXTFARBE || ERGEBNIS IN SC3$
'
GET 0,0,319,14,sc5$
DEFTEXT sc1%,1,0,10
TEXT 0,12,319,sc4$
FILESELECT sc1$,sc2$,sc3$
PUT 0,0,sc5$
sc5$=""
RETURN
' -------------------------
> PROCEDURE bilo
DIM bil$(8)
'
FOR i%=1 TO 8
CLOSE #1
OPEN "i",#1,"A:\SCHIEBER\ART\test"+STR$(i%)+".qim"
bil$(i%)=INPUT$((LOF(#1)),#1)
CLOSE #1
NEXT i%
'
DIM fahr$(5)
'
FOR i%=1 TO 5
CLOSE #1
OPEN "i",#1,"a:\SCHIEBER\ART\fahr"+STR$(i%)+".qim"
fahr$(i%)=INPUT$((LOF(#1)),#1)
CLOSE #1
NEXT i%
RETURN
' --------------------------testlaufen------------------------------'
> PROCEDURE testlauf
tstart:
SGET zum$
GOSUB testin
PUT 15,13,fahr$(2)
STICK 1
REPEAT
feuer#=STRIG(1)
PRINT AT(1,1);"TESTLAUF"
UNTIL feuer#=FALSE
'
ax%=15 !bildformat
ay%=13
' -----
m1%=7 !feld zum laufen
m2%=3 !kiste
m3%=4 !obenunten
m5%=5 !WOHIN ??
' -------------------------
x%=1
y%=1
sx%=1
sy%=1
' -----
PUT 15,13,fahr$(2)
'
thaupt:
'
' PRINT AT(1,23);sx%;" ";sy%;" "
' -------------------------
PAUSE 5
' ------
GOSUB joy
' ------
IF feuer#=TRUE
STICK 0
SPUT zum$
GOTO testende
ENDIF
' -----
' -----
IF x%<0 OR x%>20 OR y%<0 OR y%>15
GOTO thaupt
ENDIF
' -----
' -------------------------
IF x%>sx%+1
GOTO thaupt
ENDIF
' -----
IF x%<sx%-1
GOTO thaupt
ENDIF
' -----
IF y%>sy%+1
GOTO thaupt
ENDIF
' -----
IF y%<sy%-1
GOTO thaupt
ENDIF
' -----
was%=f%(x%+1,y%+1)
' -----
SELECT was%
' PRINT AT(1,24);was%;"<<"
' -----
CASE 2,5,7
frei%=0
CASE 4 !###################
IF y%=sy%+1 OR y%=sy%-1
frei%=0
ELSE
frei%=1
ENDIF
CASE 6 !##################
IF x%=sx%+1 OR x%=sx%-1
frei%=0
ELSE
frei%=1
ENDIF
DEFAULT
frei%=1
ENDSELECT
' PRINT AT(33,7);frei%;" "
' -------------------------
IF frei%=0 !FELD FREI
PUT (sx%)*ax%,(sy%)*ay%,bil$(ff%(sx%+1,sy%+1))
' -----
PUT x%*ax%,y%*ay%,fahr$(fa%)
sx%=x%
sy%=y%
GOTO weiter4 !gelaufen
ENDIF
IF frei%<>0 AND was%<>3
GOTO weiter4 !#####################
ENDIF
' -------------------------
zx%=x%+1 !FELDPOSITION
zy%=y%+1 !FELDPOSITION
' -----
' -----
IF sx%=x% !hoch runter
' -----
IF y%=sy%-1 !HOCH
GOSUB hoch
GOTO weiter3
ENDIF
' -----
IF y%=sy%+1 !RUNTER
GOSUB runter
GOTO weiter3
ENDIF
' -----
ENDIF
' -------------------------
' -------------------------
IF sy%=y% !LINKS RECHTS
' -----
IF x%=sx%-1 !LINKS
GOSUB links
GOTO weiter3
ENDIF
' -------------------------
IF x%=sx%+1 !RECHTS#######################################
GOSUB rechts
ENDIF
GOTO weiter3
ENDIF
' -----
weiter3:
PAUSE 5
weiter4:
' -----
GOTO thaupt
' --------------------------
testende:
RETURN
' -------------------------
> PROCEDURE joy
joyin:
x%=sx%
y%=sy%
'
feuer#=STRIG(1)
IF feuer#=TRUE
GOTO joyex
ENDIF
'
richtung%=STICK(1)
SELECT richtung%
CASE 4
DEC x%
fa%=1
CASE 8
INC x%
fa%=2
CASE 2
INC y%
fa%=5
CASE 1
DEC y%
fa%=4
ENDSELECT
IF x%=sx% AND y%=sy%
GOTO joyin
ENDIF
joyex:
RETURN
' -------------------------
> PROCEDURE hoch
' -----
w2%=f%(zx%,zy%) !1 FELD DANACH
w3%=f%(zx%,zy%-1) !2 FELD DANACH
IF w2%<2 OR w3%=m2% !WAND
GOTO hochex !KEIN LAUFEN
ENDIF
' -----
IF w2%=m2% AND w3%>1 !KISTE UND EXTRAFELD ODER LAUFEN
w4%=ff%(zx%,zy%) !KISTENFELD
IF w4%=m2% !AUCH KISTE WEG DAMIT
ff%(zx%,zy%)=m1% !NUN LAUFFELD
ENDIF
ELSE
GOTO hochex
ENDIF
PUT sx%*ax%,sy%*ay%,bil$(ff%(sx%+1,sy%+1)) !FELD ALTE POSITION
PUT x%*ax%,y%*ay%,fahr$(fa%) !SPIELFIGUR
PUT x%*ax%,(y%-1)*ay%,bil$(m2%) !KISTE
f%(zx%,zy%-1)=m2% !DA STEHT SIE NUN
f%(zx%,zy%)=ff%(zx%,zy%)
sx%=x%
sy%=y%
hochex:
RETURN
' -------------------------
> PROCEDURE runter
' -----
w2%=f%(zx%,zy%) !1 FELD DANACH
w3%=f%(zx%,zy%+1) !2 FELD DANACH
IF w2%<2 OR w3%=m2% !WAND
GOTO rraus !KEIN LAUFEN
ENDIF
' -----
IF w2%=m2% AND w3%>1 !KISTE UND EXTRAFELD ODER LAUFEN
w4%=ff%(zx%,zy%) !KISTENFELD
IF w4%=m2% !AUCH KISTE WEG DAMIT
ff%(zx%,zy%)=m1% !NUN LAUFFELD
ENDIF
ELSE
GOTO rraus
ENDIF
PUT sx%*ax%,sy%*ay%,bil$(ff%(sx%+1,sy%+1)) !FELD ALTE POSITION
PUT x%*ax%,y%*ay%,fahr$(fa%) !SPIELFIGUR
PUT x%*ax%,(y%+1)*ay%,bil$(m2%) !KISTE
f%(zx%,zy%+1)=m2% !DA STEHT SIE NUN
f%(zx%,zy%)=ff%(zx%,zy%)
sx%=x%
sy%=y%
rraus:
RETURN
' -------------------------
> PROCEDURE links
' -----
w2%=f%(zx%,zy%) !1 FELD DANACH
w3%=f%(zx%-1,zy%) !2 FELD DANACH
IF w2%<2 OR w3%=m2% !WAND
GOTO linksex !KEIN LAUFEN
ENDIF
' -----
IF w2%=m2% AND w3%>1 !KISTE UND EXTRAFELD ODER LAUFEN
w4%=ff%(zx%,zy%) !KISTENFELD
IF w4%=m2% !AUCH KISTE WEG DAMIT
ff%(zx%,zy%)=m1% !NUN LAUFFELD
ENDIF
ELSE
GOTO linksex
ENDIF
PUT sx%*ax%,sy%*ay%,bil$(ff%(sx%+1,sy%+1)) !FELD ALTE POSITION
PUT x%*ax%,y%*ay%,fahr$(fa%) !SPIELFIGUR
PUT (x%-1)*ax%,y%*ay%,bil$(m2%) !KISTE
f%(zx%-1,zy%)=m2% !DA STEHT SIE NUN
f%(zx%,zy%)=ff%(zx%,zy%)
sx%=x%
sy%=y%
linksex:
RETURN
' -------------------------
> PROCEDURE rechts
' -----
w2%=f%(zx%,zy%) !1 FELD DANACH
w3%=f%(zx%+1,zy%) !2 FELD DANACH
IF w2%<2 OR w3%=m2% !WAND
GOTO rechtsex !KEIN LAUFEN
ENDIF
' -----
IF w2%=m2% AND w3%>1 !KISTE UND EXTRAFELD ODER LAUFEN
w4%=ff%(zx%,zy%) !KISTENFELD
IF w4%=m2% !AUCH KISTE WEG DAMIT
ff%(zx%,zy%)=m1% !NUN LAUFFELD
ENDIF
ELSE
GOTO rechtsex
ENDIF
PUT sx%*ax%,sy%*ay%,bil$(ff%(sx%+1,sy%+1)) !FELD ALTE POSITION
PUT x%*ax%,y%*ay%,fahr$(fa%) !SPIELFIGUR
PUT (x%+1)*ax%,y%*ay%,bil$(m2%) !KISTE
f%(zx%+1,zy%)=m2% !DA STEHT SIE NUN
f%(zx%,zy%)=ff%(zx%,zy%)
sx%=x%
sy%=y%
rechtsex:
RETURN
' ----------------------testlauf ende---------------------------
> PROCEDURE testin
ERASE f%()
ERASE ff%()
ERASE fff%()
' -----
DIM f%(fx%,fy%)
DIM ff%(fx%,fy%)
DIM fff%(fx%,fy%)
' -----
FOR i%=1 TO fx%
FOR ii%=1 TO fy%
q1%=feld%(i%,ii%)
DEC q1%
f%(i%,ii%)=q1%
ff%(i%,ii%)=q1%
fff%(i%,ii%)=q1%
NEXT ii%
NEXT i%
'
RETURN
' ----------------------------pro bilo-------------------------------
'
> PROCEDURE pic1
'
CLOSE #1
OPEN "i",#1,"A:\SCHIEBER\ART\EDITOR.PI1"
farb$=SPACE$(34) !originalfarben des bildes laden
BGET #1,VARPTR(farb$),34 !und in string farb$ ablegen
z%=0
FOR i%=3 TO LEN(farb$) STEP 2 !jeweils 2 werte ergeben die farbe
farb1$=MID$(farb$,i%) !wert 1
farb2$=MID$(farb$,i%+1) !wert 2
a%=ASC(farb1$) !ascii code
b%=ASC(farb2$) !asci code
c%=a%*256+b% !wandeln in farbcode
SETCOLOR z%,c% !in die farbregister damit
INC z% !hilfszahler
NEXT i%
BGET #1,XBIOS(3),32000 !bild laden
CLOSE #1
RETURN
' -----------------------
> PROCEDURE gfa1
STICK 0
SETCOLOR 0,7,7,7
SETCOLOR 15,0
CLS
PRINT AT(1,1);"EIN FEHLER IST AUFGETRETEN"
PRINT AT(1,2);ERR$(ERR)
'
VOID INP(2)
EDIT
RETURN
' ----------------------
> PROCEDURE gfa2
STICK 0
SETCOLOR 0,7,7,7
SETCOLOR 15,0
CLS
PRINT AT(1,1);"STOP DURCH BREAK"
PRINT "FREE BYTES ";FRE(9)
'
VOID INP(2)
EDIT
RETURN
' -----------------------
'
datf1: !GERINGE AUFLÖSUNG
'
DATA 0,0,7,119
DATA 7,0,0,112,7,112,0,7,7,7,0,119,5,85,3,51,7,51,3,115,7,115,3,55,7,55,3,119
DATA 0,0